home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
pstui100.zip
/
PTUIAPP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-03-18
|
4KB
|
208 lines
{
╔══════════════════╗
║ PTUI Apps ║
║ Inlcude ║
║ Rev. 1.00 ║
╚══════════════════╝
}
Procedure DrawOutline(X1,Y1,X2,Y2:Word;LStyle:LineStyles);
Procedure DrawDoubleOutline;
Var
Y :Word;
Begin
GotoXY(X1,Y1);
WriteChr('╔');
GotoXY(X2,Y1);
WriteChr('╗');
GotoXY(X1,Y2);
WriteChr('╚');
GotoXY(X2,Y2);
WriteChr('╝');
GotoXY(X1+1,Y1);
Pad(X2-X1-1,'═');
GotoXY(X1+1,Y2);
Pad(X2-X1-1,'═');
For Y:=Y1+1 to Y2-1 do
Begin
GotoXY(X1,Y);
WriteChr('║');
GotoXY(X2,Y);
WriteChr('║');
End;
End;
Procedure DrawSingleOutline;
Var
Y :Word;
Begin
GotoXY(X1,Y1);
WriteChr('┌');
GotoXY(X2,Y1);
WriteChr('┐');
GotoXY(X1,Y2);
WriteChr('└');
GotoXY(X2,Y2);
WriteChr('┘');
GotoXY(X1+1,Y1);
Pad(X2-X1-1,'─');
GotoXY(X1+1,Y2);
Pad(X2-X1-1,'─');
For Y:=Y1+1 to Y2-1 do
Begin
GotoXY(X1,Y);
WriteChr('│');
GotoXY(X2,Y);
WriteChr('│');
End;
End;
Procedure DrawNoLineOutline;
Var
Y :Word;
Begin
GotoXY(X1,Y1);
WriteChr(' ');
GotoXY(X2,Y1);
WriteChr(' ');
GotoXY(X1,Y2);
WriteChr(' ');
GotoXY(X2,Y2);
WriteChr(' ');
GotoXY(X1+1,Y1);
Pad(X2-X1-1,' ');
GotoXY(X1+1,Y2);
Pad(X2-X1-1,' ');
For Y:=Y1+1 to Y2-1 do
Begin
GotoXY(X1,Y);
WriteChr(' ');
GotoXY(X2,Y);
WriteChr(' ');
End;
End;
Begin
If Cursor Then PushXYPos;
Case LStyle Of
DoubleLine:DrawDoubleOutline;
SingleLine:DrawSingleOutline;
NoLine :DrawNoLineOutline;
End;
If Cursor Then PopXYPos;
End;
Procedure DrawShadow(X1,Y1,X2,Y2:Word;SStyle:ShadowStyles);
Var
HashChar :Char;
OldColors :Word;
Q :Pointer;
Label
CopyLoop;
Begin
If SStyle=NoShade Then Exit;
If SStyle in [LightHash,MediumHash,DarkHash] Then
Begin
Case SStyle Of
LightHash :HashChar:=#176;
MediumHash :HashChar:=#177;
DarkHash :HashChar:=#178;
End;
FillBlock(X1+2,Y2+1,X2+1,Y2+1,HashChar);
FillBlock(X2+1,Y1+1,X2+2,Y2+1,HashChar);
End
Else
If SStyle=Solid Then
Begin
OldColors:=TextAttr;
TextColor(BackgroundColor);
FillBlock(X2+1,Y1+1,X2+1,Y2,#32);
TextAttr:=OldColors;
Q:=VideoWriteAddress(X1+1,Y2+1);
Asm
cld
push ds
mov bh, TextAttr
and bh, 0f0h
shr bh, 1
shr bh, 1
shr bh, 1
shr bh, 1
mov bl, '▀'
les di, Q
lds si, Q
mov cx, X2
sub cx, X1
inc cx
CopyLoop:
lodsw
and ah, 0f0h
or ah, bh
mov al, bl
stosw
loop CopyLoop
pop ds
End;
{
Pascal Equivalent:
For X:=X1+1 to X2 do
Begin
NewValue:=(((Q^ And 240) Or Shade) Shl 8) Or 223; [VideoColor(Q^ And 240, Shade);]
Q :=Ptr(Seg(Q^),Ofs(Q^)-1);
Move(NewValue,Q^,2); [Write('▀');]
Q :=Ptr(Seg(Q^),Ofs(Q^)+3);
End;
}
End;
End;
Procedure DrawShadowWindow(X1,Y1,X2,Y2:Word;ShadForg,ShadBack:Byte;
LStyle:LineStyles;SStyle:ShadowStyles);
Begin
DrawOutLine (X1,Y1,X2,Y2,LStyle);
FillBlock (X1+1,Y1+1,X2-1,Y2-1,#32);
VideoColor (ShadForg,ShadBack);
DrawShadow (X1,Y1,X2,Y2,SStyle);
End;
Procedure Barometer(X,Y:Word;MaxLen:Byte;WithMe:Char;
Current,EndPoint:LongInt);
Const
Previous:Byte = 0;
Var
HowFar:Byte;
Begin
GotoXY(X,Y);
HowFar:=(Current*MaxLen) Div EndPoint;
If HowFar<>Previous Then Pad(HowFar,WithMe);
Previous:=HowFar;
End;
{ Copyright 1993, Michael Gallias }